home *** CD-ROM | disk | FTP | other *** search
/ Graphics Plus / Graphics Plus.iso / libs / phigs / ptk.lha / ptk / fortran / source / demo / utiltest.f < prev    next >
Encoding:
Text File  |  1992-09-29  |  4.6 KB  |  155 lines
  1. C----------------------------------------------------------------------------
  2.  
  3. C  Module name: utiltest
  4.  
  5. C  Author: Gareth Williams.
  6.  
  7. C  Function: Tests the PHIGS Debugger and PHIGS view editor.
  8.  
  9. C  Dependencies:
  10.  
  11. C  Internal function list: 
  12.  
  13. C  External function list: 
  14.  
  15. C  Modification history: (Version), (Date), (name), (Description).
  16.  
  17. C  1.0, 30th October 1991, G. Williams, Translated to C.
  18.  
  19. C  2.0, June 1992, G. Williams, Converted to SunPHIGS 2.0.
  20.  
  21. C----------------------------------------------------------------------------
  22.  
  23.        PROGRAM utiltest
  24.  
  25.        include './sunphigs77.h'
  26.        include './sunptk77.h'
  27.  
  28. C--------------------------------------------------------------------------
  29.  
  30.        INTEGER minid, maxid, white, black, green
  31.        INTEGER grey, stid
  32.        CHARACTER*20 commandstr
  33.        CHARACTER*50 str
  34.        REAL echoarea(4)
  35.        INTEGER lencom, lenstr
  36.        LOGICAL quit, dummy
  37.        INTEGER stids(1)
  38.        LOGICAL ptkf_readphinterscript
  39.        INTEGER ptkf_stringtoint
  40.        REAL vwormt(4, 4)
  41.        REAL vwmpmt(4, 4)
  42.        REAL vwcplm(6)
  43.        INTEGER xyclpi, bclipi, fclipi
  44.        LOGICAL docolour
  45.  
  46.        implicit undefined (P, p, E, e)
  47.        
  48.        print *,('Testing the utility modules of the PHIGS Toolkit...')
  49.        print *,('Opening SunPHIGS...')
  50.  
  51.        call popph(6, 0)
  52.  
  53. C     create the workstation type (either tool or canvas) 
  54.               
  55. C     open the workstation 
  56.  
  57.        if (ptkf_readphinterscript('../../scripts/openws.scr', 0, 0) .eq.
  58. & .FALSE.) then     
  59.          goto 20
  60.        endif
  61.  
  62.        call psdus(1, PWAITD, PNIVE)
  63.  
  64. C     define colour variable
  65. C     for a MONOCHROME workstation set this value to .FALSE.
  66.  
  67.        docolour = .TRUE.
  68.    
  69. C initialise hashtables 
  70.        minid = 1
  71.        maxid = 300
  72.        call ptkf_inithashtables()
  73.        call ptkf_createhashtable('structureid', minid, maxid)
  74.        call ptkf_createhashtable('label', minid, maxid)
  75.        call ptkf_createhashtable('colourindex', 1, maxid)
  76.        call ptkf_createhashtable('viewindex', 1, maxid)
  77.        call ptkf_createhashtable('windowid', 1, maxid)
  78.        call ptkf_createhashtable('menuid', 1, maxid)
  79.        call ptkf_createhashtable('name', 1, maxid)
  80.        call ptkf_createhashtable('topologyid', 1, maxid)
  81.     
  82. C set colours 
  83.        if (docolour .eq. .TRUE.) then
  84.          call ptkf_setcolourrep(1, 'black')
  85.          call ptkf_setcolourrep(1, 'green')
  86.          call ptkf_setcolourrep(1, 'grey')
  87.          call ptkf_setcolourrep(1, 'white')
  88.          call ptkf_setcolourrep(1, 'red')
  89.          call ptkf_setcolourrep(1, 'blue')
  90.          green = ptkf_stringtoint('colourindex', 'green')
  91.          grey = ptkf_stringtoint('colourindex', 'grey')
  92.          white = ptkf_stringtoint('colourindex', 'white')
  93.          black = ptkf_stringtoint('colourindex', 'black')
  94.          call ptkf_setbackgroundcolourind(1, grey)
  95.          call ptkf_setdebuggerattrs(PFONTTRIPLEX, PFONTTRIPLEX,
  96. & grey, black, grey, green, black, white, black, grey, black)
  97.          call ptkf_setvieweditorattrs(PFONTTRIPLEX, PFONTTRIPLEX, 
  98. &grey, black, grey, green, black, white, black, grey, black)
  99.        endif
  100.     
  101. C read scripts 
  102.        dummy = ptkf_readphinterscript('../../scripts/lamp.scr', 0, 0)
  103.        dummy = ptkf_readphinterscript('../../scripts/postcard.scr', 
  104. & 0, 0)
  105.     
  106.        stid = ptkf_stringtoint('structureid', 'lamp')
  107.        stids(1) = stid
  108.     
  109. C select debugger/ view
  110.     
  111.         quit = .FALSE.
  112.         call ptkf_limit(0.0, 0.25, 0.0, 0.01, echoarea)
  113.  10     call ptkf_readstring(1, 'debugger', 
  114. & 'Input command (default = debugger) >', echoarea, 20, commandstr, lencom) 
  115.  
  116.         if (commandstr(1:lencom) .eq. 'debugger') then
  117.           print *,('Testing the PHIGS debugger module of the PHIGS 
  118. & Toolkit..')
  119.         call ptkf_readstring(1, 'lamp', 
  120. & 'Input command (default = lamp) >', echoarea, 50, str, lenstr)
  121.           stid = ptkf_stringtoint('structureid', str)
  122.           call ptkf_debugger(1, stid)
  123.  
  124.         else if (commandstr(1:lencom) .eq. 'view') then
  125.           print *,('Testing the PHIGS view editor module of the 
  126. & PHIGS Toolkit...')
  127.         call ptkf_readstring(1, 'lamp', 
  128. & 'Input command (default = lamp) >', echoarea, 50, str, lenstr)
  129.           stid = ptkf_stringtoint('structureid', str)
  130.           call ptkf_vieweditor(1, 1, stids, vwormt, vwmpmt, vwcplm, 
  131. & xyclpi, bclipi, fclipi)
  132.     
  133.        else if (commandstr(1:lencom) .eq. 'quit') then
  134.          quit = .TRUE.
  135.  
  136.        else
  137.           print *,('Command unknown')    
  138.        endif
  139.  
  140.        call prst(1, PALWAY)
  141.  
  142.        if (quit .eq. .TRUE.) then
  143.          goto 20
  144.        else 
  145.          goto 10
  146.        endif
  147.  
  148.  20    call pclwk(1)
  149.        call pclph()
  150.  
  151.        STOP
  152.        END
  153.     
  154. C--------------------------------------------------------------------------
  155.